home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Fred (editor) utilities.sea / Fred (editor) utilities / completion.lisp < prev    next >
Encoding:
Text File  |  1993-02-26  |  9.1 KB  |  207 lines  |  [TEXT/CCL2]
  1. ;;; -*- Mode: LISP; Package: (COMPLETION :USE (COMMON-LISP CCL)); Syntax:Common-Lisp; Lowercase: Yes -*-
  2.  
  3. ;;;; Completion.Lisp
  4.  
  5. ;;; This file provides a completion facility for fred windows.
  6. ;;; It is not very sophisticated, but it does useful work!
  7. ;;; And it´s free.
  8.  
  9. ;;; Just press c-i for completion of symbols.
  10.  
  11. ;;; c-i for
  12. ;;;     foo  looks in the window package    for "FOO"
  13. ;;; bar:foo  looks in the package "BAR"     for "FOO" if bar is a known package
  14. ;;; bar:foo  looks in all packages          for "FOO" if bar is a unknown package
  15. ;;;    :foo  looks in the package "KEYWORD" for "FOO"
  16.  
  17. ;;; m-i for
  18. ;;;     foo  looks in all packages for "FOO"
  19. ;;; bar:foo  looks in all packages for "FOO"
  20. ;;;    :foo  looks in all packages for "FOO"
  21.  
  22. ;;; Written by Rainer Joswig.
  23. ;;; internet:  rainer@ki4.informatik.uni-hamburg.de
  24.  
  25. ;;; Runs in MCL 2.0b1p3
  26.  
  27.  
  28. (defpackage "COMPLETION" (:use "CCL" "COMMON-LISP"))
  29.  
  30. (in-package completion)
  31.  
  32.  
  33.  
  34. (defun starting-substring-p (substring string length-of-substring)
  35.   "Returns t if substring is a starting substring of string."
  36.   (if (> length-of-substring (length string))
  37.     nil
  38.     (string-equal substring
  39.                   string
  40.                   :end2 length-of-substring)))
  41.  
  42.  
  43. (defun find-completing-symbols-in-package (symbol-name-to-complete package)
  44.   "Returns a list of completions for SYMBOL-NAME-TO-COMPLETE in package PACKAGE."
  45.   (declare (type (or string symbol) symbol-name-to-complete))
  46.   (declare (optimize (speed 3) (safety 2)))
  47.   (setf symbol-name-to-complete (string-upcase symbol-name-to-complete))
  48.   (let ((list-of-symbols nil)
  49.         (length-of-symbol-name-to-complete (length symbol-name-to-complete)))
  50.     (do-symbols (symbol package list-of-symbols)
  51.       (when (starting-substring-p symbol-name-to-complete
  52.                                   (symbol-name symbol)
  53.                                   length-of-symbol-name-to-complete)
  54.         (push symbol list-of-symbols)))))
  55.  
  56.  
  57. (defun find-all-completing-symbols (symbol-name-to-complete)
  58.   "Returns a list of all completions for SYMBOL-NAME-TO-COMPLETE."
  59.   (declare (type (or string symbol) symbol-name-to-complete))
  60.   (declare (optimize (speed 3) (safety 2)))
  61.   (setf symbol-name-to-complete (string-upcase symbol-name-to-complete))
  62.   (let ((list-of-symbols nil)
  63.         (length-of-symbol-name-to-complete (length symbol-name-to-complete)))
  64.     (do-all-symbols (symbol list-of-symbols)
  65.       (when (starting-substring-p symbol-name-to-complete
  66.                                   (symbol-name symbol)
  67.                                   length-of-symbol-name-to-complete)
  68.         (push symbol list-of-symbols)))))
  69.  
  70. (defun analyze-string-as-symbol (string default-package)
  71.   "returns symbol and package part of a string analyzed as a symbol"
  72.   (let* ((first-colon-position (position #\: string))
  73.          (second-colon-position (if first-colon-position
  74.                                   (position #\: string
  75.                                             :start (1+ first-colon-position))
  76.                                   nil)))
  77.     (values (if first-colon-position
  78.               (subseq string
  79.                       (1+ (or second-colon-position first-colon-position))
  80.                       (length string))
  81.               string)
  82.             (if first-colon-position
  83.               (if (zerop first-colon-position)
  84.                 (find-package "KEYWORD")
  85.                 (find-package (subseq string 0 first-colon-position)))
  86.               default-package))))
  87.  
  88.   
  89. (defun find-completing-symbols (symbol-name-to-complete
  90.                                 &key
  91.                                 (default-package *package*)
  92.                                 (all-packages nil))
  93.   "Returns a list of completions for SYMBOL-NAME-TO-COMPLETE."
  94.   (declare (type string symbol-name-to-complete))
  95.   (setf symbol-name-to-complete (string-upcase symbol-name-to-complete))
  96.   (multiple-value-bind (symbol package)
  97.                        (analyze-string-as-symbol symbol-name-to-complete
  98.                                                  default-package)
  99.     (when symbol
  100.       (if (or all-packages (not package))
  101.         (find-all-completing-symbols symbol)
  102.         (find-completing-symbols-in-package symbol package)))))
  103.  
  104.  
  105. (defun remove-some-characters-from-string (string)
  106.   "returns: string from-left from-right"
  107.   (let* ((string1 (string-left-trim '(#\# #\') string))
  108.          (deleted-from-left (- (length string) (length string1)))
  109.          (string2 (string-left-trim '(#\|) string1)))
  110.     (incf deleted-from-left (- (length string1) (length string2)))
  111.     (let* ((string3 (string-right-trim '(#\|) string2))
  112.            (deleted-from-right (- (length string2) (length string3))))
  113.       (values string3 deleted-from-left deleted-from-right))))
  114.  
  115.  
  116. (defun select-one-item-from-list (item-list &rest keys)
  117.   "Like select-item-from-list, but doesn´t ask if there is no or only one item."
  118.   (case (length item-list)
  119.       (0 nil)                            ; no item
  120.       (1 (first item-list))              ; just one item
  121.       (otherwise                         ; select one item from many
  122.        (let ((selection (apply #'select-item-from-list
  123.                          item-list
  124.                          :selection-type :single
  125.                          keys)))
  126.          (if (>= (length selection) 1)
  127.            (first selection)             ; take the first
  128.            nil)))))                      ; no selection
  129.  
  130.  
  131. (defmethod ed-complete-symbol ((window fred-window) &key (all-packages nil))
  132.   "Inserts a completion for the current symbol into the buffer."
  133.   (let ((buffer (fred-buffer window))
  134.         (*package* (or (fred-package window) *package*)))
  135.     (multiple-value-bind (start end)
  136.                          (buffer-current-sexp-bounds buffer)  ; well, it works
  137.       (if (and start end)
  138.         (when (eq :cancel
  139.                   (catch-cancel
  140.                    (multiple-value-bind (string-to-be-completed from-start from-end)
  141.                                         (remove-some-characters-from-string
  142.                                          (buffer-substring buffer start end))
  143.                      (set-mini-buffer window "Completing : ~A" string-to-be-completed)
  144.                      (let ((completing-symbol
  145.                             (select-one-item-from-list
  146.                              (sort (find-completing-symbols
  147.                                     string-to-be-completed
  148.                                     :default-package *package*
  149.                                     :all-packages all-packages)
  150.                                    #'string<)
  151.                              :table-print-function #'prin1
  152.                              :window-title "Select a completion.")))
  153.                        (if completing-symbol
  154.                          (progn
  155.                            (collapse-selection window t)
  156.                            (buffer-delete buffer (+ start from-start) (- end from-end))
  157.                            (buffer-insert buffer
  158.                                           (string-downcase (prin1-to-string completing-symbol))
  159.                                           (+ start from-start))
  160.                            (set-mini-buffer window "Completion : ~A" completing-symbol))
  161.                          (set-mini-buffer window
  162.                                           "No completion for ~A."
  163.                                           string-to-be-completed))))))
  164.           (set-mini-buffer window "Completion cancelled."))
  165.         (set-mini-buffer window "Completion : No valid string.")))))
  166.  
  167.  
  168. (defmethod ed-complete-symbol ((view fred-mixin) &key (all-packages nil))
  169.   "Inserts a completion for the current symbol into the buffer."
  170.   (let ((buffer (fred-buffer view))
  171.         (*package* (or (fred-package view) *package*)))
  172.     (multiple-value-bind (start end)
  173.                          (buffer-current-sexp-bounds buffer)  ; well, it works
  174.       (when (and start end)
  175.         (catch-cancel
  176.          (multiple-value-bind (string-to-be-completed from-start from-end)
  177.                               (remove-some-characters-from-string
  178.                                (buffer-substring buffer start end))
  179.            (let ((completing-symbol
  180.                   (select-one-item-from-list
  181.                    (sort (find-completing-symbols
  182.                           string-to-be-completed
  183.                           :default-package *package*
  184.                           :all-packages all-packages)
  185.                          #'string<)
  186.                    :table-print-function #'prin1
  187.                    :window-title "Select a completion.")))
  188.              (when completing-symbol
  189.                (collapse-selection view t)
  190.                (buffer-delete buffer (+ start from-start) (- end from-end))
  191.                (buffer-insert buffer
  192.                               (string-downcase
  193.                                (prin1-to-string completing-symbol))
  194.                               (+ start from-start))))))))))
  195.  
  196.  
  197. (defmethod ed-complete-symbol-in-all-packages ((view fred-mixin))
  198.   "Inserts a completion for the current symbol into the buffer."
  199.   (ed-complete-symbol view :all-packages t))
  200.  
  201.  
  202. (def-fred-command (:control #\i) ed-complete-symbol "c-i")
  203. (def-fred-command (:meta #\i) ED-COMPLETE-SYMBOL-IN-ALL-PACKAGES "m-i")
  204.  
  205. (provide 'completion)
  206.  
  207.